home *** CD-ROM | disk | FTP | other *** search
/ FM Towns: Free Software Collection 4 / FM Towns Free Software Collection 4 - Disc 1.iso / fb386 / socio / socio.bas < prev    next >
BASIC Source File  |  1991-10-18  |  12KB  |  314 lines
  1.    10 ' ############################################################
  2.    20 ' #                ソシオメトリー                            #
  3.    30 ' #                                                          #
  4.    40 ' #        開発 MZ-731      昭和５８年                       #
  5.    50 ' #        移植 FM-7        昭和５９年（打ち直し）           #
  6.    60 ' #             PC8801mk2SR 昭和６１年（ＲＳ－２３２Ｃ）     #
  7.    70 ' #             PC9801VM2   昭和６２年（コンバータ)          #
  8.    80 ' #             FM-16β     昭和６２年（エデイタ）           #
  9.    90 ' #        修正完了         昭和６３年４月                   #
  10.   100 '#                                                          #
  11.   110 '#        著作権保持者　   後藤勝美                         #
  12.   120 '#                                                          #
  13.   130 '############################################################
  14.   140 clear:console 0,24,1:defint A-Z:color 7,0:cls
  15.   150 J=2:K=5
  16.   160 '
  17.   170 gosub *INITIALIZE
  18.   180 print:input"印刷時のタイトルを入力してください       ";TI$
  19.   190 input"選択制限数(何名まで選択させるか)は       ";D
  20.   200 input"調査表を作成しますか（ﾌﾟﾘﾝﾀｰ用意）　(Y/N)";S$
  21.   210 '----- SCREEN -----
  22.   220 cls
  23.   230 if S$="Y" or S$="y" then console 0,24,0
  24.   240 if M>=(W-M) then L=int(M/2-.5)+5
  25.   250 if (W-M)>M then L=int((W-M)/2-.5)+5
  26.   260 locate 5,3:print"         ****** データを入力してください ******":Y=1
  27.   270 if Y=W+1 then Y=1
  28.   280 if Y=0 then Y=W
  29.   290 locate 0,0:print"  ";N$(Y);:color 2
  30.   300 print"  が好きな者     ":color 7
  31.   310 Z=1:goto 360
  32.   320 locate 0,0:print"  ";N$(Y);:color 1
  33.   330 print"  が嫌いな者     ":color 7
  34.   340 Z=-1
  35.   350 '--- NAME ----
  36.   360 P=0:Q=5
  37.   370 for A=1 to W
  38.   380 locate P,Q
  39.   390 if Y(Y,A)=1 and Z=1 then color 2
  40.   400 if Y(Y,A)=-1 and Z=-1then color 1
  41.   410 print using"##";A;
  42.   420 color 7,0:print" ";N$(A)
  43.   430 if Q=L then P=P+19:Q=5 else Q=Q+1
  44.   440 if A=M then P=38:Q=5
  45.   450 next
  46.   460 beep:if S$="Y" or S$="y" then *TYOUSA
  47.   470 'LINE(0,330)-(639,380),PSET,7,B
  48.   480 'PAINT(10,370),4,7
  49.   490 locate 0,21
  50.   500 print"    E:終了  M:資料ﾏﾄﾘｸｽ  G:ｿｼｵｸﾞﾗﾑ     S:調査ﾃﾞｰﾀ登録  *:次(の子)へ"
  51.   510 print"    Z:前者  N:名簿登録　 A:転入者追加  D:転出者抹消    B:ﾃﾞｰﾀ修正"
  52.   520 S$="":goto *SELECT
  53.   530 '--- ｼﾘｮｳ ﾏﾄﾘｸｽ ----
  54.   540 locate 0,19:input"資料マトリクスをプリントしますか(Y/N) ";Y$
  55.   550 if Y$="Y" or Y$="y" then 560 else 860
  56.   560 locate 0,19:print space$(70)
  57.   570 locate 0,19:input"プリンターをセットしましたか    (Y/N) ";Y$
  58.   580 lprint"< 資料マトリクス >  ";TI$
  59.   590 L1$="                     11111111112222222222333333333344444444445"
  60.   600 L2$="            12345678901234567890123456789012345678901234567890"
  61.   610 M1$=left$(L1$,W+12)
  62.   620 M2$=left$(L2$,W+12)
  63.   630 lprint
  64.   640 lprint M1$
  65.   650 lprint M2$;
  66.   660 lprint"  C  R  CRS mc mr  Isss"
  67.   670 for Q=1 to W
  68.   680  lprint using"##";Q;:lprint using"&        &";N$(Q);
  69.   690  for P=1 to W
  70.   700   if Y(P,Q)=1 and Y(Q,P)=1 then lprint"L";:C=C+1:MC=MC+1:goto 750
  71.   710   if Y(P,Q)=1 then lprint"o";:C=C+1:goto 750
  72.   720   if Y(P,Q)=-1 and Y(Q,P)=-1 then lprint"H";:R=R+1:MR=MR+1:goto 750
  73.   730   if Y(P,Q)=-1 then lprint"x";:R=R+1:goto 750
  74.   740   lprint"･";
  75.   750  next P
  76.   760  lprint using" ## ## #### ## ## ####.##";C;R;C-R;MC;MR;((C-R)/(W-1)+(MC-MR)/D)/2*1000
  77.   770  C(Q)=C:R(Q)=R:CRS(Q)=C(Q)-R(Q)
  78.   780  C=0:R=0:CRS=0:MC=0:MR=0
  79.   790 next Q
  80.   800 lprint:lprint
  81.   810 lprint"o：選択　　x：排除　　L：相互選択　　H：相互排除"
  82.   820 lprint"C：選択数　R：排除数　C-R：差引     mc：相互選択数  mr：相互排除数"
  83.   830 lprint"Isss(x1000)：地位指数"
  84.   840 lprint:lprint"COMPLEET !":beep
  85.   850 A=1:Y$="":return 210
  86.   860 locate 0,19:print space$(40):return 1110
  87.   870 '--- 構造マトリクス -----
  88.   880 '
  89.   890 '
  90.   900 '
  91.   910 '
  92.   920 '
  93.   930 '
  94.   940 '----- SELECTION --------------------------
  95.   950 *SELECT
  96.   960 locate 0,19:print space$(70)
  97.   970 locate 0,19:input"御命令を";MEI$
  98.   980 if MEI$="B" or MEI$="b" then gosub 2140
  99.   990 if MEI$="M" or MEI$="m" then gosub 540
  100.  1000 if MEI$="G" or MEI$="g" then gosub 1280
  101.  1010 if MEI$="S" or MEI$="s" then gosub 2840
  102.  1020 if MEI$="*" or MEI$="*" then goto 1240
  103.  1030 if MEI$="Z" or MEI$="z" then gosub 1260
  104.  1040 'IF MEI$="K" THEN GOSUB 900
  105.  1050 if MEI$="A" or MEI$="a" then gosub 1680
  106.  1060 if MEI$="D" or MEI$="d" then gosub 1940
  107.  1070 if MEI$="I" or MEI$="i" then gosub 3060
  108.  1080 if MEI$="E" or MEI$="e" then goto *END
  109.  1090 if MEI$="N" or MEI$="n" then gosub 2600
  110.  1100 locate 0,19:print"                       "
  111.  1110 G=val(MEI$):MEI$=""
  112.  1120 if G<=0 then G=0:MEI$="":goto *SELECT
  113.  1130 if G<=(L-4) then locate 0,G+4:goto 1180
  114.  1140 if G<=M then locate 19,G-L+8:goto 1180
  115.  1150 if G<=(M+L-4) then locate 38,G-M+4:goto 1180
  116.  1160 if G>W then goto *SELECT
  117.  1170 locate 57,G-M-L+8:goto 1180
  118.  1180 if G=Y then G=0:MEI$="":goto *SELECT
  119.  1190 if Z=1 then color 2:print using"##";G:Y(Y,G)=1
  120.  1200 if Z=-1 then color 1:print using"##";G:Y(Y,G)=-1
  121.  1210 G=0
  122.  1220 locate 0,19:print"                       "
  123.  1230 color 7:goto *SELECT
  124.  1240 if Z=1 then 320
  125.  1250 if Z=-1 then Y=Y+1:goto 270
  126.  1260 Y=Y-1:goto 270
  127.  1270 '----- ソシオグラム -----
  128.  1280 locate 0,19:input"ソシオグラムを表示しますか (Y/N) ";Y$
  129.  1290 if Y$="Y" or Y$="y" then 1300 else 1560
  130.  1300 locate 0,19:print space$(70)
  131.  1310 locate 0,19:print"選択、排除を実線で結びます。          "
  132.  1320 beep:for I=1 to 5000:next
  133.  1330 console 0,24,0:cls:gosub 1590
  134.  1340 for P=1 to W:for Q=1 to W
  135.  1350   if Y(P,Q)<>1 or Q<P then 1410
  136.  1360   X1=210*cos(3.14159/180*O*P)+330:Y1=190-160*sin(3.14159/180*O*P)
  137.  1370   X2=210*cos(3.14159/180*O*Q)+330:Y2=190-160*sin(3.14159/180*O*Q)
  138.  1380   line(X1,Y1)-((X1+X2)/2,(Y1+Y2)/2),pset,7,,&HFFFF
  139.  1390   if Y(Q,P)=1 then line((X1+X2)/2,(Y1+Y2)/2)-(X2,Y2),pset,7,,&HFFFF:goto 1410
  140.  1400   line((X1+X2)/2,(Y1+Y2)/2)-(X2,Y2),pset,7,,&H6666
  141.  1410 next Q,P
  142.  1420 locate 0,0:input"印刷しますか(Y/N) ";Y$
  143.  1430 if Y$="Y" or Y$="y" then locate 0,0:print space$(70) else 1440
  144.  1435 locate 0,0:print"< 選択 > ";TI$:hardc 4 else 1440
  145.  1440 cls:gosub 1590
  146.  1450 color 7
  147.  1460 for P=1 to W:for Q=1 to W
  148.  1470   if Y(P,Q)<>-1 or Q<P then 1530
  149.  1480   X1=210*cos(3.14159/180*O*P)+330:Y1=190-160*sin(3.14159/180*O*P)
  150.  1490   X2=210*cos(3.14159/180*O*Q)+330:Y2=190-160*sin(3.14159/180*O*Q)
  151.  1500   line(X1,Y1)-((X1+X2)/2,(Y1+Y2)/2),pset,7,,&HFFFF
  152.  1510   if Y(Q,P)=-1 then line((X1+X2)/2,(Y1+Y2)/2)-(X2,Y2),pset,7,,&HFFFF:goto 1530
  153.  1520   line((X1+X2)/2,(Y1+Y2)/2)-(X2,Y2),pset,7,,&H6666
  154.  1530 next Q,P
  155.  1540 locate 0,0:input"印刷しますか (Y/N) ";Y$
  156.  1550 if Y$="Y" or Y$="y" then locate 0,0:print space$(70) else 1560
  157.  1555 LOCATE0,0:print"< 排除 > ";TI$:hardc 4 else 1560
  158.  1560 beep
  159.  1570 Y$="":Y=1:cls 3:console 0,24,1:return 220
  160.  1580 '----- RING -----
  161.  1590 color 1:O=340/W:P=1:Q=1:CO=1
  162.  1600 for A=1 to W
  163.  1610 X1=int(240*cos(3.14159/180*O*A)+320)
  164.  1620 Y1=int(180-176*sin(3.14159/180*O*A))
  165.  1630 symbol@(X1,Y1),N$(A),1,1,CO,0,or
  166.  1640 if A=M then CO=2
  167.  1650 next A
  168.  1660 return
  169.  1670 '----- ADD NAME ----
  170.  1680 if W>47 then 950
  171.  1690 locate 0,19:input"転入者追加。追加する個人名は";H$
  172.  1700 if H$="" then 1920
  173.  1710 locate 0,19:print space$(70)
  174.  1720 locate 0,19:input"何番の後に挿入しますか";I$
  175.  1730 I=val(I$)
  176.  1740 if I>W then H$="":I$="":goto 1920
  177.  1750 for A=W+1 to I+2 step -1
  178.  1760 N$(A)=N$(A-1)
  179.  1770 next A
  180.  1780 for P=W+1 to I+2 step -1
  181.  1790 for Q=W+1 to I step -1
  182.  1800  Y(P,Q)=Y(P-1,Q)
  183.  1810 next Q,P
  184.  1820 for Q=W+1 to I+2 step -1
  185.  1830 for P=W+1 to 1 step -1
  186.  1840 Y(P,Q)=Y(P,Q-1)
  187.  1850 next P,Q
  188.  1860 for A=1 to W+1
  189.  1870 Y(I+1,A)=0:Y(A,I+1)=0
  190.  1880 next A
  191.  1890 if I=<M then M=M+1
  192.  1900 W=W+1
  193.  1910 N$(I+1)=H$:H$="":I$=""
  194.  1920 locate 0,19:print space$(70):return 210
  195.  1930 '----- ERASE -----
  196.  1940 locate 0,19:input"転出者削除。何番を削除しますか";E$
  197.  1950 if E$="" then 2120
  198.  1960 E=val(E$)
  199.  1970 for A=E to W-1
  200.  1980 N$(A)=N$(A+1)
  201.  1990 next A
  202.  2000 N$(W+1)=""
  203.  2010 for P=E to W-1:for Q=1 to W-1
  204.  2020 Y(P,Q)=Y(P+1,Q)
  205.  2030 next Q,P
  206.  2040 for Q=E to W-1:for P=1 to W-1
  207.  2050 Y(P,Q)=Y(P,Q+1)
  208.  2060 next P,Q
  209.  2070 for A=1 to W+1
  210.  2080 Y(A,W)=0:Y(W,A)=0
  211.  2090 next A
  212.  2100 if E=<M then M=M-1
  213.  2110 W=W-1:E$=""
  214.  2120 locate 0,19:print space$(70):return 210
  215.  2130 '----- DEBUG -----
  216.  2140 locate 0,19
  217.  2150 input"データ修正。何番ですか。";T$
  218.  2160 if T$="" then 2260
  219.  2170 N=val(T$)
  220.  2180 if N<1 or N>W then T$="":goto 2260
  221.  2190 Y(Y,N)=0
  222.  2200 if N<=(L-4) then locate 0,N+4:goto 2250
  223.  2210 if N<=M then locate 19,N-L+8:goto 2250
  224.  2220 if N<=(M+L-4) then locate 38,N-M+4:goto 2250
  225.  2230 if N>W then goto 2260
  226.  2240 locate 57,N-M-L+8
  227.  2250 print using"##";N:T$="":N=0
  228.  2260 locate 0,19:print space$(70)
  229.  2270 return
  230.  2280 '----- 初期設定 -----
  231.  2290 *INITIALIZE
  232.  2300 color 5:line(0,0)-(639,100),pset,,b,&H8888:print
  233.  2310 print"                            ソシオメトリー"
  234.  2320 print:print"                            製作  後藤勝美"
  235.  2330 print:print
  236.  2340 print:print:color 7
  237.  2350 input"クラスの人数は  ";W
  238.  2360 input"男子の人数は    ";M
  239.  2370 dim Y(50,50),M$(48),N$(48),C(48),R(48),CRS(48)
  240.  2380 line(0,0)-(639,100),preset,,b:print:print"1:名簿を読み込む "
  241.  2390 print"2:これから入力する    "
  242.  2400 color 2:input"どちらですか？番号を入力して下さい。";C$:color 7
  243.  2410 if C$="1" then 2700
  244.  2420 if C$="2" then 2430 else 2400
  245.  2430 beep:color 2:print:print"名前を出席番号順に入力して下さい。漢字なら１人３文字以内にすると見易いです。"
  246.  2440 color 5:print:print"〈  * を入力すると１つ前に戻ります 〉":color 7,0
  247.  2450 for A=1 to W
  248.  2460 print using"##";A;
  249.  2470 input M$(A)
  250.  2480 if M$(A)="*" then A=A-2 else 2510
  251.  2490 if A=-1 then 2450
  252.  2500 if A=0 then 2450 else 2520
  253.  2510 N$(A)=left$(M$(A),10)
  254.  2520 next
  255.  2530 print:input"登録しますか(Y/N)";B$
  256.  2540 if B$="Y" or B$="y" then 2550 else return
  257.  2550 input"ファイル名は";F$
  258.  2560 open F$ for output as #1
  259.  2570 for A=1 to W:print #1,N$(A):next A
  260.  2580 close:beep:print"終りました":return
  261.  2590 '----- SAVE NAME DATA -----
  262.  2600 locate 0,19:input"名前を登録しますか(Y/N) ";Y$
  263.  2610 if Y$="Y" or Y$="y" then 2620 else 2670
  264.  2620 locate 0,19:print space$(70)
  265.  2630 locate 0,19:input"ファイル名は";F$
  266.  2640 open F$ for output as #1
  267.  2650 for A=1 to W:print #1,N$(A):next
  268.  2660 close:beep
  269.  2670 locate 0,19:print space$(70)
  270.  2680 Y$="":return
  271.  2690 '----- LOAD DATA -----
  272.  2700 files:color 2:print"これがドライブ０のファイル一覧表です。この中から選んで下さい。":color 7
  273.  2710 input"ファイル名は";F$
  274.  2720 open F$ for input as #1
  275.  2730 for A=1 to W:input #1,N$(A):next
  276.  2740 close:beep:print
  277.  2750 input"データを読み込みますか(Y/N)";D$
  278.  2760 if D$="Y" or D$="y" then 2770 else return
  279.  2770 input"ファイル名は";F$
  280.  2780 open F$ for input as #1
  281.  2790 for X=1 to W:for Y=1 to W
  282.  2800 input #1,Y(X,Y)
  283.  2810 next Y,X
  284.  2820 close:D$="":beep:cls:return
  285.  2830 '----- SAVE DATA -----
  286.  2840 locate 0,19
  287.  2850 input"データを登録しますか(Y/N) ";Y$
  288.  2860 if Y$="Y" or Y$="y" then 2870 else 2940
  289.  2870 locate 0,19:print space$(70)
  290.  2880 locate 0,19:input"ファイル名は ";F$
  291.  2890 open F$ for output as #1
  292.  2900 for X=1 to W:for Y=1 to W
  293.  2910 print #1,Y(X,Y)
  294.  2920 next Y,X
  295.  2930 close:D$="":beep:return
  296.  2940 locate 0,19:print space$(70)
  297.  2950 Y$="":return
  298.  2960 '----- 調査表 ----------------
  299.  2970 *TYOUSA
  300.  2980 locate 0,0:print"友だちしらべ     (   番   氏名                    )"
  301.  2990 print:print"おなじはんになりたい人･･･････○（";D;"人まで）              "
  302.  3000 print"おなじはんになりたくない人･･･×（";D;"人まで）                    "
  303.  3010 print"                                                         "
  304.  3020 locate 0,18:print"＊他の人のを見ないで、だまって書きなさい。"
  305.  3030 print"＊あてはまる人がいなければ、書かなくてよい。"
  306.  3040 print"＊出席番号順に提出しなさい。"
  307.  3050 hardc 4:S$="":console 0,24,1:goto 220
  308.  3060 '----- PROGRUM END -------------
  309.  3070 *END
  310.  3080 locate 0,19:input"プログラムを終わりますか (Y/N)";Y$
  311.  3090 if Y$="Y" or Y$="y" then 3100 else 3110
  312.  3100 cls:new
  313.  3110 locate 0,19:print space$(79):goto *SELECT
  314.